home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / REDUCE.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  13KB  |  518 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /* This file contains various functions needed for reduce actions */
  10.  
  11. #include "hdr.h"
  12. #include "ada.h"
  13. #include "adared.h"
  14. #include "setp.h"
  15. #include "smiscp.h"
  16. #include "prsutilp.h"
  17. #include "errsp.h"
  18. #include "adalexp.h"
  19. #include "pspansp.h"
  20. #include "reducep.h"
  21.  
  22. static void pragma_warning(Node);
  23. static int in_label_set(Node, Tuple);
  24. static int is_pragma(int);
  25.  
  26. void free_everything(Node n)
  27. {
  28. }
  29.  
  30. struct two_pool *initlist(Node node)                /*;initlist*/
  31. {
  32.     /* Allocate a single list structure (struct two_pool), set its data to
  33.      * be a pointer to the node given, and set its link field to point
  34.      * to itself, since tree node lists are circular.
  35.      */
  36.     struct two_pool *tmp;
  37.  
  38.     tmp = TALLOC();
  39.     tmp->val.node = node;
  40.     tmp->link = tmp;
  41.     return(tmp);
  42. }
  43.  
  44. void append(Node orignode, Node node)            /*;append*/
  45. {
  46.     /* Append node to list within orignode */
  47.  
  48.     if (N_LIST(orignode) == (Tuple)0) 
  49.         N_LIST(orignode) = tup_new1((char *)node);
  50.     else
  51.         N_LIST(orignode) = tup_with(N_LIST(orignode), (char *)node);
  52. }
  53.  
  54. void prepend(Node node, Node orignode)        /*;prepend*/
  55. {
  56.     /* Prepends list within orignode with node */
  57.  
  58.     Tuple beglist = tup_new1((char *)node);
  59.  
  60.     if (N_LIST(orignode) == (Tuple)0)
  61.         N_LIST(orignode) = beglist;
  62.     else
  63.         N_LIST(orignode) = tup_add(beglist, N_LIST(orignode));
  64. }
  65.  
  66. Node binary_operator(Node optr, Node expr1, Node expr2)        /*;binary_operator*/
  67. {
  68.     /* Set up the AST node for a binary operator. */
  69.  
  70.     Node node, arg_list_node;
  71.  
  72.     node = node_new(as_op);
  73.     arg_list_node = node_new(as_list);
  74.     N_LIST(arg_list_node) = tup_new2((char *)expr1, (char *)expr2);
  75.     insert_2child(node, optr, arg_list_node);
  76.     return(node);
  77. }
  78.  
  79. Node unary_operator(Node optr, Node expr)                /*;unary_operator*/
  80. {
  81.     /* Set up the AST node for a unary operator. */
  82.     Node node, arg_list_node;
  83.  
  84.     node = node_new(as_un_op);
  85.     arg_list_node = node_new(as_list);
  86.     N_LIST(arg_list_node) = tup_new1((char *)expr);
  87.     insert_2child(node, optr, arg_list_node);
  88.     return(node);
  89. }
  90.  
  91. int check_expanded_name(Node name)            /*;check_expanded_name*/
  92. {
  93.     /* Make sure an expanded name node is valid. */
  94.  
  95. #define sub_expanded_name (N_AST1(name))
  96.     return((N_KIND(name) == as_selector) ? 
  97.       check_expanded_name(sub_expanded_name) : (N_KIND(name)== as_simple_name));
  98. #undef sub_expanded_name
  99. }
  100.  
  101. void check_discrete_range(Node discrete_range) /*;check_discrete_range*/
  102. {
  103.     /* Check whether a discrete range node is valid. */
  104.  
  105.     switch (N_KIND(discrete_range))
  106.     {
  107.     case as_range_expression :
  108. #define name (N_AST1(discrete_range))
  109.         if (!check_expanded_name(name))
  110.             syntax_err(SPAN(discrete_range),
  111.               "Invalid discrete_range specification");
  112.         else
  113.             N_KIND(discrete_range) = as_name;
  114.         break;
  115. #undef name
  116.     case as_range_attribute :
  117.     case as_subtype :
  118.         break;
  119.     default :
  120.         syntax_err(SPAN(discrete_range),
  121.           "Invalid discrete_range specification");
  122.     }
  123. }
  124.  
  125. static void pragma_warning(Node pragma_node)            /*;pragma_warning*/
  126. {
  127.     /* Give a warning that a pragma is ignored. */
  128.  
  129.     char msg[MAXLINE + 30];
  130.  
  131. #define id (N_AST1(pragma_node))
  132.     sprintf(msg,"Pragma %s is ignored", namelist(N_ID(id)));
  133.     prs_warning(SPAN(pragma_node),msg);
  134. #undef id
  135. }
  136.  
  137. void pragmalist_warning(Node list_node)        /*;pragmalist_warning*/
  138. {
  139.     /* For all nodes in the list of list_node give a warning the the pragma
  140.      * is invalid.
  141.      */
  142.  
  143.     Node tmp_node;
  144.     Fortup ft1;
  145.  
  146.     if (N_LIST(list_node) != (Tuple)0) {
  147.         FORTUP(tmp_node = (Node), N_LIST(list_node), ft1);
  148.             pragma_warning(tmp_node);
  149.         ENDFORTUP(ft1);
  150.     }
  151. }
  152.  
  153. void check_pragmas(Node pragma_node, int (*allowed_test)(int))
  154.                                                     /*;check_pragmas*/
  155. {
  156.     /* Check that a pragma is valid. */
  157.  
  158.     Tuple new_list = tup_new(0);
  159.     Node tmp_node;
  160.     Fortup ft1;
  161.     int id;
  162.  
  163.     if (N_LIST(pragma_node) != (Tuple)0) {
  164.         FORTUP(tmp_node = (Node), N_LIST(pragma_node), ft1);
  165.             id = N_ID(N_AST1(tmp_node));
  166.             if (is_pragma(id) && (*allowed_test)(id - MIN_PRAGMA)) {
  167.                 if (strcmp(namelist(id),"PRIORITY")
  168.                   && strcmp(namelist(id),"ELABORATE")
  169.                   && strcmp(namelist(id),"INTERFACE")) {
  170.                     pragma_warning(tmp_node);
  171.                 }
  172.                 else
  173.                     new_list = tup_with(new_list, (char *)tmp_node);
  174.             }
  175.             else if (is_pragma(id) && ispredef_pragma[id - MIN_PRAGMA]) {
  176.                 char msg[200];
  177.  
  178.                 sprintf(msg,"Pragma %s is not valid in this context",
  179.                   namelist(id));
  180.                 prs_warning(SPAN(tmp_node),msg);
  181.             }
  182.             else if (!(is_pragma(id) && isimpldef_pragma[id - MIN_PRAGMA])
  183.               && strcmp(namelist(id),"OPTIMIZE")) {
  184.                 pragma_warning(tmp_node);
  185.             }
  186.             else
  187.                 new_list = tup_with(new_list, (char *)tmp_node);
  188.         ENDFORTUP(ft1);
  189.         N_LIST(pragma_node) = new_list;
  190.     }
  191. }
  192.  
  193. int isoverloadable_op(char *str)                /*;isoverloadable_op*/
  194. {
  195.     /* Check whether a string represnts an overloadable operator by
  196.      * comparing against all overloadable operators.
  197.      */
  198.  
  199.     char tmp[MAXLINE + 1];
  200.     int i;
  201.  
  202.     strcpy(tmp, str);
  203.     convtolower(tmp);
  204.     for (i = 0; i < NUMOVERLOADOPS; i++)
  205.         if (!strcmp(tmp, overloadable_operators[i]))
  206.             return(1);
  207.     return(0);
  208. }
  209.  
  210. /* The following functions are for passing to check_pragmas */
  211.  
  212. int immediate_decl_pragmas(int p)                /*;immediate_decl_pragmas*/
  213. {
  214.     return(isimmediate_decl_pragma[p]);
  215. }
  216.  
  217. int compilation_pragmas(int p)                    /*;compilation_pragmas*/
  218. {
  219.     return(iscompilation_pragma[p]);
  220. }
  221.  
  222. int after_libunit_pragmas(int p)                /*;after_libunit_pragmas*/
  223. {
  224.     return(isafter_libunit_pragma[p]);
  225. }
  226.  
  227. int task_pragmas(int p)                            /*;task_pragmas*/
  228. {
  229.     return(istask_pragma[p]);
  230. }
  231.  
  232. int task_repr_pragmas(int p)                    /*;task_repr_pragmas*/
  233. {
  234.     return(istask_pragma[p] || isrepr_pragma[p]);
  235. }
  236.  
  237. int context_pragmas(int p)                        /*;context_pragmas*/
  238. {
  239.     return(iscontext_pragma[p]);
  240. }
  241.  
  242. int null_pragmas(int i)                                    /*;null_pragmas*/
  243. {
  244.     return(i = 0);
  245. }
  246.  
  247. void check_choices(Node alt_node, char *source)    /*;check_choices*/
  248. {
  249.     Tuple choice_list, others_indices = tup_new(0);
  250.     Node tmp_node, tmp_node2, last_alt = (Node) 0;
  251.     Fortup ft1, ft2;
  252.     int choice_flag = 0;
  253.  
  254.     FORTUP(tmp_node = (Node), N_LIST(alt_node), ft1);
  255.         if (N_KIND(tmp_node) != as_pragma) {
  256.             choice_list = N_LIST(N_AST1(tmp_node));
  257.             if (tup_size(choice_list) > 1) {
  258.                 FORTUP(tmp_node2 = (Node), choice_list, ft2);
  259.                     if (N_KIND(tmp_node2) == as_others
  260.                       || N_KIND(tmp_node2) == as_others_choice) {
  261.                         char msg[90];
  262.  
  263.                         sprintf(msg,"The choice OTHERS must appear alone in %s",
  264.                           source);
  265.                         syntax_err(SPAN(tmp_node2),msg);
  266.                         choice_flag = 1;
  267.                         break;
  268.                     }
  269.                 ENDFORTUP(ft2);
  270.             }
  271.                if (!choice_flag) {
  272.                 if (N_KIND((Node)choice_list[1]) == as_others
  273.                   || N_KIND((Node)choice_list[1]) == as_others_choice)
  274.                     others_indices = tup_with(others_indices, (char *)tmp_node);
  275.             }
  276.             else
  277.                 choice_flag = 0;
  278.             last_alt = tmp_node;
  279.         }
  280.     ENDFORTUP(ft1);
  281.  
  282.     FORTUP(tmp_node = (Node), others_indices, ft1); {
  283.         Node choice;
  284.         char msg[90];
  285.  
  286.         if (tmp_node == last_alt)
  287.             continue;
  288.         choice = (Node)N_LIST(N_AST1(tmp_node))[1];
  289.         sprintf(msg,"The choice OTHERS must appear last in %s",source);
  290.         syntax_err(SPAN(choice),msg);
  291.     } ENDFORTUP(ft1);
  292. /*
  293.     if (others_indices != (struct two_pool *)0 )
  294.         TFREE(others_indices->link,others_indices);
  295. */
  296. }
  297.  
  298. Tuple remove_duplicate_labels(Tuple label_list)
  299.                                             /*;remove_duplicate_labels*/
  300. {
  301.     Tuple new_label_list = tup_new(0), label_id_set = tup_new(0);
  302.     Fortup ft1, ft2;
  303.     Node tmp_node, tmp_node2, node, label;
  304.  
  305.     FORTUP(tmp_node = (Node), label_list, ft1);
  306.         if (N_KIND((node = tmp_node)) == as_simple_name) {
  307.             if (in_label_set(node, label_id_set))
  308.                 syntax_err(SPAN(node),"Duplicate label name");
  309.             else {
  310.                 /* new_label_list = concatl(new_label_list,initlist(node)); */
  311.                 label_id_set = tup_with(label_id_set, (char *)node);
  312.             }
  313.             new_label_list = tup_with(new_label_list, (char *)node);
  314.         }
  315.         else {
  316.             FORTUP(tmp_node2 = (Node), N_LIST(node), ft2);
  317.                 label = tmp_node2;
  318.                 if (in_label_set(label,label_id_set))
  319.                     syntax_err(SPAN(label),"Duplicate label name");
  320.                 else
  321.                     label_id_set = tup_with(label_id_set, (char *)label);
  322.             ENDFORTUP(ft2);
  323.         }
  324.     ENDFORTUP(ft1)
  325. /*
  326.     if (label_id_set != (struct two_pool *)0)
  327.